home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / hier-menu-demo.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  17.2 KB  |  405 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;hier-menu-demo.lisp
  3. ;;
  4. ;; Copyright © 1992 University of Toronto, Department of Computer Science
  5. ;; All Rights Reserved
  6. ;;
  7. ;; author: Mark A. Tapia
  8. ;;
  9. ;; A demonstration of hierarchical marking menus
  10. ;;
  11. ;; To use this demonstration, first load "init-menus.lisp" and "make-menus.lisp"
  12. ;; and then evaluate the form:
  13. ;;  (menus::load-hier-demo)
  14. ;; Finally evalute the form:
  15. ;;  (hier-demo)
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. (in-package cl-user)
  19. (use-package 'menus)
  20.  
  21. (eval-when (eval compile)
  22.   (require 'oou-utils)
  23.   (require 'marking-menus)
  24.   (require 'check-menus))
  25. (import '(menus::queued-modal-dialog menus::containing-view))
  26.  
  27. (defvar text)
  28.  
  29. (setq text
  30. "Hierarchical marking menus
  31.  
  32. To invoke a marking menu, press the mouse 
  33. button down and hold it down. The menu will
  34. appear.
  35.  
  36. Like standard menus, menu items in marking menus 
  37. may also be menus. These items are are denoted
  38. by a > and are called 'sub-menus'
  39.  
  40. Sub-menus can be invoked by dragging the 
  41. rubber-band line outside the circle, pausing,
  42. while keeping the mouse button pressed down.
  43. The sub-menu will then appear.
  44.  
  45. To backup to a previous menu, stretch the
  46. rubber-band line to the center of the menu
  47. and then select another option.
  48.  
  49. While menus can be nested to any depth, it
  50. is better to nest to at most three levels.
  51. When each level contains four choices, this
  52. allows access to sixty-four (64) items by
  53. passing through three menus.
  54.  
  55. Five options control the presentation of
  56. hierarchical menus. The options are described
  57. below.
  58.  
  59. The recommended options are
  60.       on : Float, Hide, Turn
  61.       off: Opaque, Keep
  62.  
  63. Options marked with an asterisk (*) affect
  64. only hierarchical menus:
  65.     Float    
  66.       on : menus resemble spokes of wheel and float
  67.            above the surface of the view
  68.       off: menus are pie-shaped
  69. *   Hide
  70.       on : when selecting a submenu,hides
  71.            the other siblings
  72.       off: show all sibling menu items when select-
  73.            ing a sub-menu
  74. *   Turn
  75.       on : alternate between on/off axis menus
  76.       off: all menus are either on/off axis
  77. *   Opaque
  78.       on:  menu greys out the underlying view
  79.       off: menu obscures the underlying view
  80. *   Keep
  81.       on:  removes other siblings when a sub-menu
  82.            is invoked.Retains the highlighted and
  83.            selected wedge or spoke
  84.       off: always places the menu item to the left
  85.            of the anchoring circle.
  86.  
  87. Experiment with the options to determine their
  88. effect on the presentation.")
  89.  
  90. (defun to-lines (text)
  91.   "Return a list containing the separate lines of the string"
  92.   (let (n lines)
  93.     (loop
  94.       (setq n (position #\Newline text))
  95.       (unless n (push text lines)
  96.               (return (nreverse lines)))
  97.       (when (minusp n)
  98.         (push text lines)
  99.         (return (nreverse lines)))
  100.       (push (if (zerop n) ""
  101.                 (subseq text 0 n))
  102.             lines)
  103.       (setq text (subseq text (1+ n))))))
  104.  
  105. (defmethod scroll-down ((self table-dialog-item))
  106.   (let* ((first-cell (point-v (scroll-position self)))
  107.          (ncells (point-v (table-dimensions self)))
  108.          (visible-dimensions (point-v (visible-dimensions self)))
  109.          (last-cell (min (1- (+ first-cell visible-dimensions))
  110.                          (- ncells visible-dimensions))))
  111.     (when (< last-cell ncells)
  112.       (scroll-to-cell self (make-point 1 last-cell))
  113.        (< (+ last-cell visible-dimensions) ncells))))
  114.  
  115. (defmethod scroll-up ((self table-dialog-item))
  116.   (let* ((first-cell (point-v (scroll-position self)))
  117.          (visible-dimensions (point-v (visible-dimensions self)))
  118.          new-cell)
  119.       (setq new-cell (max 0 (1+ (- first-cell visible-dimensions))))
  120.       (scroll-to-cell self (make-point 1 new-cell))
  121.       (not (zerop new-cell))))
  122.  
  123. (defclass unhilited-table (marking-menu-table)
  124.   ()
  125.   (:default-initargs :auto-size t
  126.     :menu-font default-font))
  127.  
  128. (defmethod highlight-table-cell ((marking-menu-table unhilited-table) cel rect selectedp)
  129.   (declare (ignore marking-menu-table cel rect selectedp)))
  130.  
  131. (defun make-help-file ()
  132.   (let (that table prev next end)
  133.     (setq that
  134.           (make-instance 'dialog 
  135.                          :window-type :double-edge-box
  136.                          :window-show nil
  137.                          :view-position :centered
  138.                          :view-size #@(434 359)               
  139.                          :close-box-p nil 
  140.                          :view-font '("Chicago" 12 :srcor :plain)))
  141.     (add-subviews that
  142.                   (setq table (make-instance 'unhilited-table 
  143.                                              :view-position  #@(11 16) 
  144.                                              :view-size #@(402 290)
  145.                                              :view-font '("Courier" 12 :srccopy :plain)
  146.                                              :cell-size #@(385 16) 
  147.                                              :table-hscrollp nil 
  148.                                              :table-vscrollp t 
  149.                                              :table-sequence 
  150.                                              '()))
  151.                   
  152.                   (make-dialog-item 'button-dialog-item 
  153.                                     #@(364 326) 
  154.                                     #@(62 16)
  155.                                     "Ok" 
  156.                                     #'(lambda (item) 
  157.                                         (let* ((window (view-window item)))
  158.                                           (eval-enqueue `(window-hide ,window))))
  159.                                     :default-button t))
  160.     (setq prev (make-instance 'window-menu-item
  161.                              :menu-item-title "Prev"
  162.                              :disabled t)
  163.           end (make-instance 'window-menu-item
  164.                              :menu-item-title "Close"
  165.                              :menu-item-action 
  166.                              #'(lambda (item) 
  167.                                  (let* ((container (containing-view item))
  168.                                         (window (view-window container)))
  169.                                    (eval-enqueue `(window-hide ,window)))))
  170.           
  171.           next (make-instance 'window-menu-item
  172.                               :menu-item-title "Next"))
  173.     (add-menu-items table prev end next (make-instance 'empty-menu-item))
  174.     (setf (menu-item-action-function prev)
  175.           #'(lambda (item)
  176.               (let* ((container (containing-view item))
  177.                      (next (find-menu-item container "Next"))
  178.                      (prev (find-menu-item container "Prev")))
  179.                 (eval-enqueue
  180.                  `(progn 
  181.                     (unless (scroll-up ,container)
  182.                       (menu-item-disable ,prev))
  183.                     (menu-item-enable ,next)))))
  184.           
  185.           (menu-item-action-function next)
  186.           #'(lambda (item)
  187.               (let* ((container (containing-view item))
  188.                      (next (find-menu-item container "Next"))
  189.                      (prev (find-menu-item container "Prev")))
  190.                 (eval-enqueue
  191.                  `(progn 
  192.                     (unless (scroll-down ,container)
  193.                       (menu-item-disable ,next))
  194.                     (menu-item-enable ,prev))))))
  195.     (set-table-sequence table (to-lines text))
  196.     (set-table-dimensions table 1 (length (table-sequence table)))
  197.     that))
  198.  
  199. (defun change-main-option (item flag)
  200.   "Changes the option in the root menu for the slot with name flag"
  201.   (setf (slot-value (containing-view item) flag)
  202.         (menu-item-check-mark item)))
  203.  
  204. (defvar *help* (make-help-file))
  205.  
  206. (defun test-hier (&key floating turn hide in-position opaque)
  207.   (let (that 
  208.         roger 
  209.         rabbit 
  210.         options 
  211.         (standard-font default-font)
  212.         m-floating m-turn m-hide m-opaque m-in-position)
  213.     (setq that (make-instance 'marking-menu-window
  214.                               :hide hide
  215.                               :in-position in-position
  216.                               :menu-floating floating
  217.                               :menu-font standard-font
  218.                               :auto-size t))
  219.     (add-subviews that
  220.                   (make-instance 'static-text-dialog-item 
  221.                                  :view-position #@(49 34)
  222.                                  :view-size  #@(223 60) 
  223.                                  :dialog-item-text (format nil "Hold the mouse button down to try ~
  224.                                                                 hierarchical marking menus. ~
  225.                                                                 Experiment with the options ~
  226.                                                                 in the submenu 'Menus >'")
  227.                                  :view-font '("Chicago" 12 :srccopy :plain)))
  228.     (add-menu-items that
  229.                     (make-instance 'menu-item
  230.                                    :menu-item-title "Help"
  231.                                    :menu-item-action 
  232.                                    #'(lambda ()
  233.                                        (eval-enqueue `(help-demo))))
  234.                     (setq options (make-instance 'marking-menu-view
  235.                                                  :menu-font standard-font
  236.                                                  :menu-item-title "Menus"
  237.                                                  :auto-size t))
  238.                     (setq roger (make-instance 'marking-menu-view
  239.                                                :menu-font standard-font
  240.                                                :menu-title "View"
  241.                                                :auto-size t))
  242.                     (if (and (boundp '*custom*)
  243.                              *custom*)
  244.                       (make-instance 'window-menu-item
  245.                                      :menu-item-title "Demo…"
  246.                                      :menu-item-action
  247.                                      #'(lambda (item)
  248.                                          (when (fboundp 'marking-demo)
  249.                                            (let ((container (containing-view item)))
  250.                                            (eval-enqueue
  251.                                             `(progn
  252.                                               (window-hide ,container)
  253.                                               (marking-demo)
  254.                                               (window-show ,container)))))))
  255.                       (make-instance 'empty-menu-item)))
  256.     
  257.     (setq m-floating (make-instance 'check-window-menu-item
  258.                                     :menu-item-title "Float"
  259.                                     :mark "√")
  260.           m-hide (make-instance 'check-window-menu-item
  261.                                 :menu-item-title "Hide"
  262.                                 :mark "√")
  263.           m-opaque (make-instance 'check-window-menu-item
  264.                                   :menu-item-title "Opaque"
  265.                                   :mark "√")
  266.           m-turn (make-instance 'check-window-menu-item
  267.                                 :menu-item-title "Turn"
  268.                                 :mark "√")
  269.           m-in-position (make-instance 'check-window-menu-item
  270.                                        :menu-item-title "Keep"
  271.                                        :mark "√"))
  272.     (set-menu-item-check-mark m-floating floating)
  273.     (set-menu-item-check-mark m-turn turn)
  274.     (set-menu-item-check-mark m-hide hide)
  275.     (set-menu-item-check-mark m-opaque opaque)
  276.     (set-menu-item-check-mark m-in-position in-position)
  277.     
  278.     (add-menu-items options
  279.                     m-floating
  280.                     m-hide
  281.                     m-opaque
  282.                     m-turn
  283.                     m-in-position
  284.                     (make-instance 'menu-item
  285.                                    :menu-item-title "Help"
  286.                                    :menu-item-action 
  287.                                    #'(lambda ()
  288.                                        (eval-enqueue `(help-demo)))))
  289.     
  290.     (setf (menu-item-action-function m-floating)
  291.           #'(lambda (item)
  292.               (let ((container (containing-view item)))
  293.                 (eval-enqueue
  294.                  `(setf (slot-value  ,container 'menus::menu-floating)
  295.                         (not (slot-value ,container 'menus::menu-floating)))))))
  296.     
  297.     (setf (menu-item-action-function m-hide)
  298.           #'(lambda (item)
  299.               (change-main-option item 'menus::hide)))
  300.     
  301.     (setf (menu-item-action-function m-opaque)
  302.           #'(lambda (item)
  303.               (change-main-option item 'menus::menu-opaque)))
  304.     
  305.     (setf (menu-item-action-function m-turn)
  306.           #'(lambda (item)
  307.               (change-main-option item 'menus::turn)))
  308.     
  309.     (setf (menu-item-action-function m-in-position)
  310.           #'(lambda (item)
  311.               (change-main-option item 'menus::in-position)))
  312.     
  313.     (add-menu-items roger
  314.                     (make-instance 'window-menu-item
  315.                                    :menu-item-title "Close"
  316.                                    :menu-item-action #'(lambda (item)
  317.                                                          (let ((container
  318.                                                                 (containing-view item)))
  319.                                                            (eval-enqueue `(window-close ,container)))))
  320.                     (make-instance 'menu-item
  321.                                    :menu-item-title "Beep"
  322.                                    :menu-item-action #'(lambda ()
  323.                                                          (ED-BEEP)))
  324.  
  325.                     (make-instance 'window-menu-item
  326.                                    :menu-item-title (if *custom* "Exp" "Beep 2")
  327.                                    :menu-item-action (if *custom* 
  328.                                                        #'(lambda (item)
  329.                                                            (let ((container (containing-view item)))
  330.                                                              (when (find-package :game) 
  331.                                                              (eval-enqueue
  332.                                                               (list 'progn 
  333.                                                                     (list 'window-hide container)
  334.                                                                     (list 'in-package 'game)
  335.                                                                     (list 'do-exp)
  336.                                                                     (list 'in-package 'cl-user)
  337.                                                                     (list 'window-select container))))))
  338.                                                        #'(lambda (item)
  339.                                                            (declare (ignore item))
  340.                                                            (dotimes (i 2)
  341.                                                              (ED-BEEP)))))
  342.  
  343.                     (setq rabbit (make-instance 'marking-menu-view
  344.                                                 :menu-font standard-font
  345.                                                 :menu-item-title "Zoom")))
  346.     (add-menu-items rabbit
  347.                     (make-instance 'menu-item
  348.                                    :menu-item-title "Grow"
  349.                                    :menu-item-action
  350.                                    #'(lambda () (let ((form (list 'cl-user::zoom-it that)))
  351.                                                   (eval-enqueue form))))
  352.                     (make-instance 'menu-item
  353.                                    :menu-item-title "Normal"
  354.                                    :disabled t)
  355.                     (make-instance 'window-menu-item
  356.                                    :menu-item-title "Close"
  357.                                    :menu-item-action #'(lambda (item)
  358.                                                          (let ((container
  359.                                                                 (containing-view item)))
  360.                                                            (eval-enqueue `(window-close ,container)))))
  361.                     (make-instance 'menu-item
  362.                                    :menu-item-title "Beep"
  363.                                    :menu-item-action #'(lambda ()
  364.                                                          (ED-BEEP))))
  365.     that))
  366.  
  367. (defun hier-marking-demo ()
  368.   (let ((that (test-hier :floating t :turn t :hide t :in-position nil)))
  369.     (loop
  370.       while (wptr that)
  371.       do (when *eval-queue*
  372.            (loop
  373.              while *eval-queue*
  374.              do (eval (pop *eval-queue*)))))))
  375.  
  376. (defun help-demo ()
  377.   (unless (and (boundp '*help*) 
  378.                (wptr *help*))
  379.     (setq *help* (make-help-file)))
  380.   (window-select *help*)
  381.   (queued-modal-dialog *help* nil)
  382.   (window-hide *help*))
  383.  
  384. (defun hier-demo ()
  385.   (hier-marking-demo)
  386.   (window-close *help*)
  387.   (%set-toplevel (if *testing* #'toplevel-loop
  388.                      nil)))
  389.  
  390. (defun make-hier-demo ()
  391.   "Create the experiment application"
  392.   (let ((target-appl (choose-new-file-dialog :directory "ccl;hier")))
  393.     (set-menubar nil)
  394.     (setq *testing* nil)
  395.     (save-application target-appl
  396.                       :excise-compiler t    ; don't want the compiler
  397.                       :creator :hier
  398.                       :clear-clos-caches nil ; otherwise we can't access classes
  399.                       :toplevel-function #'hier-demo)))
  400.  
  401. #|
  402. (test-hier :floating t :turn t :hide t :in-position nil)  
  403. (make-hier-demo)
  404. |#
  405.